VERSION 5.00
Begin VB.UserControl NewToolBar 
   Alignable       =   -1  'True
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   ToolboxBitmap   =   "NewToolBar.ctx":0000
   Begin VB.PictureBox p1 
      BorderStyle     =   0  'None
      Height          =   495
      Left            =   600
      ScaleHeight     =   33
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   65
      TabIndex        =   0
      Top             =   840
      Width           =   975
   End
   Begin VB.Timer t1 
      Enabled         =   0   'False
      Interval        =   10
      Left            =   120
      Top             =   840
   End
End
Attribute VB_Name = "NewToolBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function FrameRect Lib "USER32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FillRect Lib "USER32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "USER32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function PtInRect Lib "USER32" (lpRect As RECT, ByVal ptX As Long, ByVal ptY As Long) As Long
Private Declare Function ClientToScreen Lib "USER32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetParent Lib "USER32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function ShowWindow Lib "USER32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function EnableWindow Lib "USER32" (ByVal hWnd As Long, ByVal fEnable As Long) As Long
Private Const SW_HIDE = 0
Private Const SW_SHOW = 5

Private Type POINTAPI
        x As Long
        y As Long
End Type

Private bm As New cAlphaDibSection

Private uw As Long, uh As Long
Private iw As Long, ih As Long
Private az As Boolean, fnt As StdFont, symb As New StdFont
Private dd As Boolean, bdr As Boolean, trans As Long

Private hl As Long, stat As Long
Private hlx As Long, hly As Long
Private hldd As Boolean

Private mnu As clsXPMenu
Private popCount As Long

Implements IEventContainer

Event BarClick(ByVal Index As Long)
Event BarDropDown(ByVal Index As Long, Cancel As Boolean)
Event ItemClick(ByVal MenuKey As String, ByVal Index As Long)
Event AutoResized(ByVal Height As Long)

Public Sub Redraw()
Dim r As RECT, i As Long
Dim x As Long, y As Long, w As Long
Dim hbr As Long, clr As Long
Dim d As typMenuItem
r.Right = uw
r.Bottom = uh
GradientFillRect bm.hdc, r, &HFBE3D1, &HE3AB84, GRADIENT_FILL_RECT_V
If bdr Then
 r.Top = uh - 1
 hbr = CreateSolidBrush(&H9C613B)
 FillRect bm.hdc, r, hbr
 DeleteObject hbr
End If
If mnu Is Nothing Then 'xp!!
 p1_Paint
 Exit Sub
End If
For i = 1 To mnu.MenuCount
 d = mnu.fMenuItem(i)
 If d.st = 2 Then 'panel?
  If d.vs Then
   If d.x = 0 Then w = d.y Else w = d.x
   CheckPos x, y, w + 1 '.... width=height?? :-|
   SetParent d.obj_hwnd, p1.hWnd
   d.obj.Move (x + 1) * 15, (y + 1) * 15, w * 15, (ih + 4) * 15 'picture box isn't right
   EnableWindow d.obj_hwnd, IIf(d.en, 1, 0)
   ShowWindow d.obj_hwnd, SW_SHOW
   x = x + w + 1
  Else
   ShowWindow d.obj_hwnd, SW_HIDE
   SetParent d.obj_hwnd, 0
  End If
 ElseIf d.vs And Not d.st = 3 Then 'isn't panel
  If d.st = 1 Then 'sp...tor
   w = 6
   CheckPos x, y, w
   '=====
   r.Top = y + 2
   r.Bottom = y + ih + 3
   r.Left = x + 3
   r.Right = x + 4
   hbr = CreateSolidBrush(&HCB8C6A)
   FillRect bm.hdc, r, hbr
   DeleteObject hbr
   r.Left = x + 4
   r.Right = x + 5
   hbr = CreateSolidBrush(vbWhite)
   FillRect bm.hdc, r, hbr
   DeleteObject hbr
   'fix the error
   r.Bottom = y + ih + 5
  ElseIf d.gf Or d.Text = "" Then 'picture only
   w = iw + 5
   If d.bPopupmenu Then w = w + 9
   CheckPos x, y, w
   '=====
   r.Top = y + 1
   r.Bottom = y + ih + 5
   r.Left = x + 1
   r.Right = x + w
   If d.cd And hl <> i Then 'checked border
    GradientFillRect bm.hdc, r, &H7DDDFA, &H4EBCF5, GRADIENT_FILL_RECT_V
    hbr = CreateSolidBrush(&H800000)
    FrameRect bm.hdc, r, hbr
    DeleteObject hbr
   End If
   If Not d.en Then 'icon and box
    mnu.ImlObject.Draw bm.hdc, d.IconNum - 1, eIconDIsabled, r.Left + 2, r.Top + 2
    clr = &H9B8B72
   ElseIf hl = i Then
    If stat = 2 Then
     GradientFillRect bm.hdc, r, &HFBE3D1, &HE3AB84, GRADIENT_FILL_RECT_V
    ElseIf stat = 1 Or d.cd Then
     GradientFillRect bm.hdc, r, &H5586F8, &HA37D2, GRADIENT_FILL_RECT_V
    Else
     GradientFillRect bm.hdc, r, &HD0FCFD, &H9DE0FD, GRADIENT_FILL_RECT_V
    End If
    hbr = CreateSolidBrush(&H800000)
    FrameRect bm.hdc, r, hbr
    DeleteObject hbr
    mnu.ImlObject.Draw bm.hdc, d.IconNum - 1, eIconHighlighted, r.Left + 2, r.Top + 2
    clr = &H800000
   Else
    mnu.ImlObject.Draw bm.hdc, d.IconNum - 1, eIconStandard, r.Left + 2, r.Top + 2
    clr = vbBlack
   End If
   If d.IconNum = 0 And d.cd Then 'draw checked
    If d.st = 4 Then 'checkbox
     symb.Size = 16
     DrawTextB bm.hdc, "a", symb, r.Left + 3, r.Top, _
iw, r.Bottom - r.Top, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, clr, , True 'checkbox
    Else 'no!
     symb.Size = 12
     DrawTextB bm.hdc, "=", symb, r.Left + 1, r.Top, _
iw, r.Bottom - r.Top, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, clr, , True 'optionbox
    End If
   End If
   If d.bPopupmenu Then 'dropdown mark
    r.Left = x + iw + 4
    If hl = i And d.en Then
     hbr = CreateSolidBrush(&H800000)
     FrameRect bm.hdc, r, hbr
     DeleteObject hbr
    End If
    symb.Size = 7
    DrawTextB bm.hdc, "6", symb, r.Left + 1, r.Top, _
r.Right - r.Left, r.Bottom - r.Top, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, clr, , True 'the "v"
   End If
  Else '/////////////////////////////button has caption
   DrawTextB bm.hdc, d.Text, fnt, 0, 0, w, 16, DT_CALCRECT Or DT_SINGLELINE
   w = w + 4
   If d.IconNum > 0 And mnu.ImlObject.hIml <> 0 Then w = w + iw + 4
   If d.bPopupmenu Then w = w + 9
   CheckPos x, y, w
   '=====
   r.Top = y + 1
   r.Bottom = y + ih + 5
   r.Left = x + 1
   r.Right = x + w
   If d.cd And hl <> i Then 'checked
    GradientFillRect bm.hdc, r, &H7DDDFA, &H4EBCF5, GRADIENT_FILL_RECT_V
    hbr = CreateSolidBrush(&H800000)
    FrameRect bm.hdc, r, hbr
    DeleteObject hbr
   End If
   If Not d.en Then 'box and icon
    mnu.ImlObject.Draw bm.hdc, d.IconNum - 1, eIconDIsabled, r.Left + 2, r.Top + 2
    clr = &H9B8B72
   ElseIf hl = i Then
    If stat = 2 Then
     GradientFillRect bm.hdc, r, &HFBE3D1, &HE3AB84, GRADIENT_FILL_RECT_V
    ElseIf stat = 1 Or d.cd Then
     GradientFillRect bm.hdc, r, &H5586F8, &HA37D2, GRADIENT_FILL_RECT_V
    Else
     GradientFillRect bm.hdc, r, &HD0FCFD, &H9DE0FD, GRADIENT_FILL_RECT_V
    End If
    hbr = CreateSolidBrush(&H800000)
    FrameRect bm.hdc, r, hbr
    DeleteObject hbr
    mnu.ImlObject.Draw bm.hdc, d.IconNum - 1, eIconHighlighted, r.Left + 2, r.Top + 2
    clr = &H800000
   Else
    mnu.ImlObject.Draw bm.hdc, d.IconNum - 1, eIconStandard, r.Left + 2, r.Top + 2
    clr = vbBlack
   End If
   If d.bPopupmenu Then 'dropdown
    r.Left = r.Right - 10
    If hl = i And d.en Then
     hbr = CreateSolidBrush(&H800000)
     FrameRect bm.hdc, r, hbr
     DeleteObject hbr
    End If
    symb.Size = 7
    DrawTextB bm.hdc, "6", symb, r.Left + 1, r.Top, _
r.Right - r.Left, r.Bottom - r.Top, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, clr, , True 'the "v"
   End If
   'draw caption
   r.Left = x + 1
   If d.IconNum > 0 And mnu.ImlObject.hIml <> 0 Then r.Left = r.Left + iw + 4
   DrawTextB bm.hdc, d.Text, fnt, r.Left + 2, r.Top, w, r.Bottom - r.Top, DT_LEFT Or DT_VCENTER Or DT_SINGLELINE, clr, , True
  End If
  x = x + w
 End If
Next i
y = r.Bottom + 1
If az And y <> uh Then
 UserControl.Height = y * 15
 RaiseEvent AutoResized(y)
Else
 p1_Paint
End If
End Sub

Private Sub CheckPos(x As Long, y As Long, ByVal xOff As Long)
If x + xOff > uw Then
 x = 0
 y = y + ih + 5
End If
End Sub

Private Sub IEventContainer_fClick(Sender As clsXPMenu, ByVal Index As Long)
RaiseEvent ItemClick(Sender.GetMenuName, Index)
End Sub

Private Sub IEventContainer_fMenuDestroy()
Debug.Assert popCount > 0
If popCount > 0 Then popCount = popCount - 1
If popCount = 0 Then
 stat = 0
 hl = 0
 Redraw
End If
End Sub

Private Sub IEventContainer_fMenuInit()
popCount = popCount + 1
End Sub

Private Sub IEventContainer_fReset()
stat = 0
hl = 0
Redraw
End Sub

Private Sub t1_Timer()
Dim r As RECT, p As POINTAPI
GetCursorPos p
If WindowFromPoint(p.x, p.y) <> p1.hWnd Then
 hl = 0
 hldd = False
 Redraw
 p1.ToolTipText = ""
 t1.Enabled = False
End If
End Sub

Private Sub p1_Click()
Dim i As Long, p As POINTAPI
Dim d As typMenuItem, d2 As typMenuItem
Dim b As Boolean
If hl = 0 Or mnu Is Nothing Then Exit Sub 'xp!
d = mnu.fMenuItem(hl)
If Not (d.en Or d.vs) Then Exit Sub 'xp!!
'///////////////////internal procress
If Not hldd Then
 Select Case d.st
 Case 4 'checkbox
  d.cd = Not d.cd
  mnu.fMenuItem(hl) = d
 Case 5, 6 'option button
  If d.cd = True Then
   If d.st = 6 Then d.cd = False
   mnu.fMenuItem(hl) = d
  Else
   For i = 1 To mnu.MenuCount
    d2 = mnu.fMenuItem(i)
    If d2.gn = d.gn And d2.st = d.st Then
     d2.cd = i = hl
     mnu.fMenuItem(i) = d2
    End If
   Next i
  End If
 End Select
End If
If d.bPopupmenu And (dd Or d.dd Or hldd) Then
 RaiseEvent BarDropDown(hl, b)
' If Not b Then
'  stat = 2
'  t1.Enabled = False
'  '======
'  p.x = hlx
'  p.y = hly
'  ClientToScreen UserControl.hWnd, p
'  mnu.PreInit Me
'  mnu.KillPopupMenus
'  d.mnuSubMenu.PreInit Me
'  d.mnuSubMenu.Transparent = trans
'  d.mnuSubMenu.ShowMenu p.x, p.y - 1
' End If
End If
If Not hldd Then RaiseEvent BarClick(hl)
Redraw
End Sub

Private Sub UserControl_Initialize()
symb.Name = "Webdings"
UserControl_Resize
End Sub

Private Sub UserControl_InitProperties()
Set fnt = UserControl.Font
End Sub

Private Sub p1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If stat = 0 Then
 stat = 1
 If hl > 0 Then Redraw
End If
End Sub

Private Sub p1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim r As RECT, i As Long
Dim xx As Long, yy As Long, w As Long
Dim hbr As Long, clr As Long
Dim d As typMenuItem
If mnu Is Nothing Or stat = 2 Then Exit Sub 'xp!
For i = 1 To mnu.MenuCount
 d = mnu.fMenuItem(i)
 If d.vs And Not d.st = 3 Then
  If d.st = 2 Then 'panel
   If d.x = 0 Then w = d.y Else w = d.x
   w = w + 1
   CheckPos xx, yy, w
  ElseIf d.st = 1 Then 'sp...tor
   w = 6
   CheckPos xx, yy, w
  ElseIf d.gf Or d.Text = "" Then 'picture only
   w = iw + 5
   If d.bPopupmenu Then w = w + 9
   CheckPos xx, yy, w
   '=====
   r.Top = yy + 1
   r.Bottom = yy + ih + 5
   r.Left = xx + 1
   r.Right = xx + w
  Else '/////////////////////////////button has caption
   DrawTextB bm.hdc, d.Text, fnt, 0, 0, w, 16, DT_CALCRECT Or DT_SINGLELINE
   w = w + 4
   If d.IconNum > 0 And mnu.ImlObject.hIml <> 0 Then w = w + iw + 4
   If d.bPopupmenu Then w = w + 9
   CheckPos xx, yy, w
   '=====
   r.Top = yy + 1
   r.Bottom = yy + ih + 5
   r.Left = xx + 1
   r.Right = xx + w
  End If
  If d.en And Not d.st = 1 And Not d.st = 2 Then
   If PtInRect(r, x, y) Then
    If hl <> i Then
     p1.ToolTipText = ConvertString(d.Text)
     hlx = r.Left
     hly = r.Bottom
     hl = i
     Redraw
     t1.Enabled = True
    End If
    hldd = d.bPopupmenu And x > r.Right - 12
    Exit Sub
   End If
  End If
  xx = xx + w
 End If
Next i
If hl <> 0 Then
 p1.ToolTipText = ""
 hl = 0
 hldd = False
 Redraw
End If
End Sub

Private Sub p1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If stat = 1 Then
 stat = 0
 If hl > 0 Then Redraw
End If
End Sub

Private Sub p1_Paint()
On Error Resume Next
bm.PaintPicture p1.hdc
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
With PropBag
 Set fnt = .ReadProperty("Font", UserControl.Font)
 az = .ReadProperty("AutoResize", False)
 dd = .ReadProperty("AlwaysDropDown", False)
 bdr = .ReadProperty("ShowBorder", False)
 trans = .ReadProperty("Transparent", 0)
End With
Redraw
End Sub

Private Sub UserControl_Resize()
uw = UserControl.ScaleWidth
uh = UserControl.ScaleHeight
bm.Create uw, uh
p1.Move 0, 0, uw, uh
Redraw
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag
 .WriteProperty "Font", fnt, UserControl.Font
 .WriteProperty "AutoResize", az, False
 .WriteProperty "AlwaysDropDown", dd, False
 .WriteProperty "ShowBorder", bdr, False
 .WriteProperty "Transparent", trans, 0
End With
End Sub

Public Property Get MenuObject() As clsXPMenu
Set MenuObject = mnu
End Property

Public Property Set MenuObject(obj As clsXPMenu)
Set mnu = obj
If Not obj Is Nothing Then
 With obj.ImlObject
  iw = .IconWidth
  ih = .IconHeight
  If iw = 0 Then iw = 16
  If ih = 0 Then ih = 16
 End With
End If
Redraw
End Property

Public Property Get Font() As StdFont
Set Font = fnt
End Property

Public Property Set Font(obj As StdFont)
Set fnt = obj
Redraw
End Property

Public Property Get AutoResize() As Boolean
AutoResize = az
End Property

Public Property Let AutoResize(ByVal b As Boolean)
az = b
If Not mnu Is Nothing Then Redraw
End Property

Private Function ConvertString(ByVal s As String) As String
Dim s1 As String
s1 = Replace(s, "&&", Chr(257))
s1 = Replace(s1, "&", "")
s1 = Replace(s1, Chr(257), "&")
ConvertString = s1
End Function

Public Property Get AlwaysDropDown() As Boolean
AlwaysDropDown = dd
End Property

Public Property Let AlwaysDropDown(ByVal b As Boolean)
dd = b
End Property

Public Property Get ShowBorder() As Boolean
ShowBorder = bdr
End Property

Public Property Let ShowBorder(ByVal b As Boolean)
bdr = b
Redraw
End Property

Public Property Get hWnd() As Long
hWnd = UserControl.hWnd
End Property

Public Property Get Transparent() As Long
Transparent = trans
End Property

Public Property Let Transparent(ByVal n As Long)
trans = n
End Property

